home *** CD-ROM | disk | FTP | other *** search
/ Point Programming 1 / PPROG1.ISO / pascal / swag / printing.swg / 0037_Postscript File Manipulat.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-08-25  |  8.0 KB  |  315 lines
  1. {
  2.  
  3. Date: 07-03-94 (04:34)              Number: 131410 of 132082 (Refer# NONE)
  4.   To: KERRY SOKALSKY
  5. From: MARTIN_P@EFN.EFN.ORG
  6. Subj: Re: SWAG
  7. Read: 07-04-94 (01:01)              Status: RECEIVER ONLY
  8. Conf: Internet_Mail (104)        Read Type: READING ALL (+)
  9.  
  10. From: Martin Preishuber <martin_p@efn.efn.org>
  11.  
  12. postscrp.pas unit, to create postscript files.. it includes the
  13.   common commands like line, outtext and so on
  14. psdemo.pas demo program for postscrp.pas. i made it to show, how
  15.   to use the PSSetViewPort and PSOpen-commands.
  16.  
  17. }
  18.  
  19. PROGRAM PSDemo;
  20.  
  21. USES Postscrp;
  22.  
  23. BEGIN
  24.   PSSetViewPort(0, 0, 21, 29.7);
  25.   PSOpen('test.ps', 0, 479, 639, 479);
  26.   PSTextSettings('Times-Roman', 40);
  27.   PSOutTextXY(100, 100, 'Test');
  28.   PSClose;
  29. END.
  30.  
  31.  
  32. UNIT PostScrp;
  33.  
  34. INTERFACE
  35.  
  36. USES Dos, Graph;
  37.  
  38. TYPE Viereck = ARRAY[1..4] OF PointType;
  39.      Polygon = ARRAY[1..100] OF PointType;
  40.  
  41. PROCEDURE PSSetViewPort(x1, y1, x2, y2 : REAL);
  42. PROCEDURE PSSetGray(intensity : REAL);
  43. PROCEDURE PSSetCmykColor(cyan, magenta, yellow, black : REAL);
  44. PROCEDURE PSSetRGBColor(rot, gruen, blau : REAL);
  45. PROCEDURE PSSetHsbColor(hue, saturation, brightness : REAL);
  46. PROCEDURE PSTextSettings(font : STRING; groesse : WORD);
  47. PROCEDURE PSTextAngle(angle : REAL);
  48. PROCEDURE PSOuttextxy(x, y : REAL; s : STRING);
  49. PROCEDURE PSWriteNum(x, y, num : REAL);
  50. PROCEDURE PSCircle(x, y, radius : REAL);
  51. PROCEDURE PSLineWidth(x : REAL);
  52. PROCEDURE PSLine(x1, y1, x2, y2 : REAL);
  53. PROCEDURE PSRectangle(x1, y1, x2, y2 : REAL);
  54. PROCEDURE PSMoveTo(x, y : REAL);
  55. PROCEDURE PSLineTo(x, y : REAL);
  56. PROCEDURE PSBar(x1, y1, x2, y2  : REAL);
  57. PROCEDURE PsFillViereck(VAR points : Viereck);
  58. PROCEDURE PSFillPoly(anzahl : BYTE; VAR PolyPoints : Polygon);
  59. PROCEDURE PSOpen(filename : STRING; ursprx, urspry, maxx, maxy : WORD);
  60. PROCEDURE PSClose;
  61. FUNCTION PSError : BOOLEAN;
  62. FUNCTION PixelToZoll(x : REAL) : WORD;
  63.  
  64. IMPLEMENTATION
  65.  
  66. CONST einheit = 2.54/72;
  67.       faktor = 3/140;
  68.  
  69. VAR psfile : Text;
  70.     error : BOOLEAN;
  71.     dx, dy,
  72.     ux1, uy1,
  73.     xdim, ydim,
  74.     diffx, diffy : REAL;
  75.     newviewport : BOOLEAN;
  76.  
  77. FUNCTION PSError : BOOLEAN;
  78. BEGIN
  79.   PSError := error;
  80. END;
  81.  
  82. PROCEDURE PSSetViewPort(x1, y1, x2, y2 : REAL);
  83. VAR breite,hoehe : REAL;
  84. BEGIN
  85.   breite := x2 - x1;
  86.   IF breite <= 0 THEN breite := 15;
  87.   hoehe := y2 - y1;
  88.   IF hoehe <= 0 THEN hoehe := 15;
  89.   ux1 := x1 / einheit;
  90.   uy1 := y1 / einheit;
  91.   xdim := breite / einheit;
  92.   ydim := hoehe / einheit;
  93.   newviewport := TRUE;
  94. END;
  95.  
  96. PROCEDURE PSSetGray(intensity : REAL);
  97. BEGIN
  98.   WriteLn(psfile, intensity:4:2, ' sg');
  99. END;
  100.  
  101. PROCEDURE PSSetRGBColor(rot, gruen, blau : REAL);
  102. BEGIN
  103.   WriteLn(psfile, rot:4:2, ' ', gruen:4:2, ' ', blau:4:2, ' sr');
  104. END;
  105.  
  106. PROCEDURE PSSetCmykColor(cyan, magenta, yellow, black : REAL);
  107. BEGIN
  108.   WriteLn(psfile,cyan:4:2, ' ', magenta:4:2, ' ', yellow:4:2, ' ', black:4:2,'
  109. sc');
  110. END;
  111.  
  112. PROCEDURE PSSetHsbColor(hue, saturation, brightness : REAL);
  113. BEGIN
  114.   WriteLn(psfile, hue:4:2, ' ', saturation:4:2, ' ', brightness:4:2, ' sh');
  115. END;
  116.  
  117. FUNCTION PixelToZoll(x : REAL) : WORD;
  118. BEGIN
  119.   PixelToZoll := Round(x * dx);
  120. END;
  121.  
  122. PROCEDURE PSTextSettings(font : STRING; groesse : WORD);
  123. BEGIN
  124.   WriteLn(psfile, '/', font, ' findfont ',groesse,' scalefont setfont');
  125. END;
  126.  
  127. PROCEDURE PSTextAngle(angle : REAL);
  128. BEGIN
  129.   WriteLn(psfile, angle:4:2,' rotate');
  130. END;
  131.  
  132. PROCEDURE PSOuttextxy(x,y : REAL; s : STRING);
  133. BEGIN
  134.   x := x - diffx;
  135.   y := diffy - y;
  136.   WriteLn(psfile, x * dx:4:2, ' ', y * dy:4:2, ' m');
  137.   WriteLn(psfile, '(',s,')', ' show');
  138. END;
  139.  
  140. PROCEDURE PSWriteNum(x, y, num : REAL);
  141. VAR help : STRING;
  142. BEGIN
  143.   x := x - diffx;
  144.   y := diffy - y;
  145.   Str(num:4:2, help);
  146.   WriteLn(psfile, x * dx:4:2, ' ', y * dy:4:2, ' m');
  147.   WriteLn(psfile, '(',help,')', ' show');
  148. END;
  149.  
  150. PROCEDURE PSCircle(x, y, radius : REAL);
  151. BEGIN
  152.   x := x - diffx;
  153.   y := diffy - y;
  154.   WriteLn(psfile, x * dx:4:2, ' ', y * dy:4:2, ' ', radius:4:2, ' 0 360 arc
  155. s');
  156. END;
  157.  
  158. PROCEDURE PSLineWidth(x : REAL);
  159. BEGIN
  160.   WriteLn(psfile, x:4:2, ' setlinewidth');
  161. END;
  162.  
  163. PROCEDURE PSLine(x1, y1, x2, y2 : REAL);
  164. BEGIN
  165.   x1 := x1 - diffx;
  166.   y1 := diffy - y1;
  167.   x2 := x2 - diffx;
  168.   y2 := diffy - y2;
  169.   WriteLn(psfile, x1 * dx:4:2, ' ', y1 * dy:4:2, ' m');
  170.   WriteLn(psfile, x2 * dx:4:2, ' ', y2 * dy:4:2, ' l s');
  171. END;
  172.  
  173. PROCEDURE PSRectangle(x1, y1, x2, y2 : REAL);
  174. VAR xn1, xn2, yn1, yn2 : REAL;
  175. BEGIN
  176.   x1 := x1 - diffx;
  177.   y1 := diffy - y1;
  178.   x2 := x2 - diffx;
  179.   y2 := diffy - y2;
  180.   xn1 := x1 * dx;
  181.   yn1 := y1 * dy;
  182.   xn2 := x2 * dx;
  183.   yn2 := y2 * dy;
  184.   WriteLn(psfile, 'n');
  185.   WriteLn(psfile, xn1:4:2, ' ', yn1:4:2, ' m');
  186.   WriteLn(psfile, xn2:4:2, ' ', yn1:4:2, ' l');
  187.   WriteLn(psfile, xn2:4:2, ' ', yn2:4:2, ' l');
  188.   WriteLn(psfile, xn1:4:2, ' ', yn2:4:2, ' l');
  189.   WriteLn(psfile, 'c s');
  190. END;
  191.  
  192. PROCEDURE PSMoveTo(x, y : REAL);
  193. BEGIN
  194.   x := x - diffx;
  195.   y := diffy - y;
  196.   WriteLn(psfile, x * dx:4:2, ' ', y * dy:4:2, ' m');
  197. END;
  198.  
  199. PROCEDURE PSLineTo(x, y : REAL);
  200. BEGIN
  201.   x := x - diffx;
  202.   y := diffy - y;
  203.   WriteLn(psfile, x * dx:4:2, ' ', y * dy:4:2, ' l');
  204. END;
  205.  
  206. PROCEDURE PSBar(x1, y1, x2, y2 : REAL);
  207. VAR xn1, xn2, yn1, yn2 : REAL;
  208. BEGIN
  209.   x1 := x1 - diffx;
  210.   y1 := diffy - y1;
  211.   x2 := x2 - diffx;
  212.   y2 := diffy - y2;
  213.   xn1 := x1 * dx;
  214.   yn1 := y1 * dy;
  215.   xn2 := x2 * dx;
  216.   yn2 := y2 * dy;
  217.   WriteLn(psfile, 'n');
  218.   WriteLn(psfile, xn1:4:2, ' ', yn1:4:2, ' m');
  219.   WriteLn(psfile, xn2:4:2, ' ', yn1:4:2, ' l');
  220.   WriteLn(psfile, xn2:4:2, ' ', yn2:4:2, ' l');
  221.   WriteLn(psfile, xn1:4:2, ' ', yn2:4:2, ' l');
  222.   WriteLn(psfile, 'c');
  223.   WriteLn(psfile, 'f');
  224. END;
  225.  
  226. PROCEDURE PsFillViereck(VAR points : Viereck);
  227. BEGIN
  228.   WriteLn(psfile, 'n');
  229.   WriteLn(psfile, (points[1].x - diffx) * dx:4:2, ' ', (diffy - points[1].y) *
  230. dy:4:2, ' m');
  231.   WriteLn(psfile, (points[2].x - diffx) * dx:4:2, ' ', (diffy - points[2].y) *
  232. dy:4:2, ' l');
  233.   WriteLn(psfile, (points[3].x - diffx) * dx:4:2, ' ', (diffy - points[3].y) *
  234. dy:4:2, ' l');
  235.   WriteLn(psfile, (points[4].x - diffx) * dx:4:2, ' ', (diffy - points[4].y) *
  236. dy:4:2, ' l');
  237.   WriteLn(psfile, 'c');
  238.   WriteLn(psfile, 'f');
  239. END;
  240.  
  241. PROCEDURE PSFillPoly(anzahl : BYTE; VAR PolyPoints : Polygon);
  242. VAR i : BYTE;
  243. BEGIN
  244.   IF anzahl = 1 THEN
  245.   ELSE
  246.     IF anzahl=2 THEN
  247.       PSLine(PolyPoints[1].x, PolyPoints[1].y, PolyPoints[2].x,
  248. PolyPoints[2].y)
  249.     ELSE
  250.       BEGIN
  251.         WriteLn(psfile, 'n');
  252.         WriteLn(psfile, (PolyPoints[1].x - diffx) * dx:4:2, ' ', (diffy -
  253. PolyPoints[1].y) * dy:4:2, ' m');
  254.         FOR i := 2 TO anzahl DO
  255.           WriteLn(psfile, (PolyPoints[i].x - diffx) * dx:4:2, ' ', (diffy -
  256. PolyPoints[i].y) * dy:4:2, ' l');
  257.         WriteLn(psfile, 'c');
  258.         WriteLn(psfile, 'f');
  259.       END;
  260. END;
  261.  
  262. PROCEDURE PSOpen(filename : STRING; ursprx, urspry, maxx, maxy : WORD);
  263. BEGIN
  264.   error:=FALSE;
  265.   Assign(psfile,filename);
  266.   {$I-}
  267.   Rewrite(psfile);
  268.   {$I+}
  269.   IF IOResult<>0 THEN
  270.     error:=FALSE
  271.   ELSE
  272.     BEGIN
  273.       diffx:=ursprx;
  274.       diffy:=urspry;
  275.       IF newviewport THEN
  276.         BEGIN
  277.           WriteLn(psfile,'%!PS-Adobe-2.0');
  278.           WriteLn(psfile,'/l',' ','{ lineto } def');
  279.           WriteLn(psfile,'/li',' ','{ line } def');
  280.           WriteLn(psfile,'/m',' ','{ moveto } def');
  281.           WriteLn(psfile,'/f',' ','{ fill } def');
  282.           WriteLn(psfile,'/n',' ','{ newpath } def');
  283.           WriteLn(psfile,'/c',' ','{ closepath } def');
  284.           WriteLn(psfile,'/s',' ','{ stroke } def');
  285.           WriteLn(psfile,'/sr',' ','{ setrgbcolor } def');
  286.           WriteLn(psfile,'/sh',' ','{ sethsbcolor } def');
  287.           WriteLn(psfile,'/sc',' ','{ setcmykcolor } def');
  288.           WriteLn(psfile,'/sg',' ','{ setgray } def');
  289.           WriteLn(psfile,ux1:4:2,' ',uy1:4:2,' ','translate');
  290.           dx:=xdim/maxx;
  291.           dy:=ydim/maxy;
  292.         END
  293.       ELSE
  294.         BEGIN
  295.           dx:=800/maxx;
  296.           dy:=750/maxy;
  297.         END;
  298.       WriteLn(psfile,'n');
  299.     END;
  300. END;
  301.  
  302. PROCEDURE PSClose;
  303. BEGIN
  304.   WriteLn(psfile,'showpage');
  305.   {$I-}
  306.   Close(psfile);
  307.   {$I+}
  308.   IF IOResult<>0 THEN error:=TRUE;
  309. END;
  310.  
  311. BEGIN
  312.   newviewport:=FALSE;
  313. END.
  314.  
  315.